home *** CD-ROM | disk | FTP | other *** search
/ Nebula 1 / Nebula One.iso / Internet / WWW / Perl_WWW_Utilities / MHonArc / lib / mhutil.pl < prev    next >
Encoding:
Perl Script  |  1996-04-16  |  22.1 KB  |  814 lines
  1. ##---------------------------------------------------------------------------##
  2. ##  File:
  3. ##      mhutil.pl
  4. ##  Author:
  5. ##      Earl Hood       ehood@convex.com
  6. ##  Date:
  7. ##    Wed Apr 17 00:46:26 CDT 1996
  8. ##  Description:
  9. ##      Utility routines for MHonArc
  10. ##---------------------------------------------------------------------------##
  11. ##    MHonArc -- Internet mail-to-HTML converter
  12. ##    Copyright (C) 1995    Earl Hood, ehood@convex.com
  13. ##
  14. ##    This program is free software; you can redistribute it and/or modify
  15. ##    it under the terms of the GNU General Public License as published by
  16. ##    the Free Software Foundation; either version 2 of the License, or
  17. ##    (at your option) any later version.
  18. ##
  19. ##    This program is distributed in the hope that it will be useful,
  20. ##    but WITHOUT ANY WARRANTY; without even the implied warranty of
  21. ##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22. ##    GNU General Public License for more details.
  23. ##
  24. ##    You should have received a copy of the GNU General Public License
  25. ##    along with this program; if not, write to the Free Software
  26. ##    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  27. ##---------------------------------------------------------------------------##
  28.  
  29. package main;
  30.  
  31. %Month2Num = (
  32.     'Jan', 0, 'Feb', 1, 'Mar', 2, 'Apr', 3, 'May', 4, 'Jun', 5, 'Jul', 6,
  33.     'Aug', 7, 'Sep', 8, 'Oct', 9, 'Nov', 10, 'Dec', 11,
  34. );
  35. %WDay2Num = (
  36.     'Sun', 0, 'Mon', 1, 'Tue', 2, 'Wed', 3, 'Thu', 4, 'Fri', 5, 'Sat', 6,
  37. );
  38.  
  39. ##---------------------------------------------------------------------------##
  40. ##    MHonArc based routines
  41. ##---------------------------------------------------------------------------##
  42. ##---------------------------------------------------------------------------
  43. ##    read_fmt_file() parses the resource file.  The name is misleading.
  44. ##    (The code for this routine could probably be simplified).
  45. ##
  46. sub read_fmt_file {
  47.     local($file) = shift;
  48.     local($line, $tag, $label, $acro, $hr, $type, $routine, $plfile,
  49.       $url, $arg);
  50.     local($elem, $attr, $override);
  51.  
  52.     if (!open(FMT, $file)) {
  53.     warn "Warning: Unable to open resource file: $file\n";
  54.     return 0;
  55.     }
  56.     print STDOUT "Reading resource file: $file ...\n"  unless $QUIET;
  57.     while ($line = <FMT>) {
  58.     next unless $line =~ /^\s*<([^>]+)>/;
  59.     ($elem, $attr) = split(' ', $1, 2);
  60.     $elem =~ tr/A-Z/a-z/;
  61.     $override = ($attr =~ /override/i);
  62.     FMTSW: {
  63.     if ($elem eq "botlinks") {        # Bottom links in message
  64.         $BOTLINKS = '';
  65.         while ($line = <FMT>) {
  66.         last  if $line =~ /^\s*<\/botlinks\s*>/i;
  67.         $BOTLINKS .= $line;
  68.         }
  69.         last FMTSW;
  70.     }
  71.     if ($elem eq "docurl") {        # Doc URL
  72.         while ($line = <FMT>) {
  73.         last  if $line =~ /^\s*<\/docurl\s*>/i;
  74.         next  if $line =~ /^\s*$/;
  75.         $line =~ s/\s//g; $DOCURL = $line;
  76.         }
  77.         last FMTSW;
  78.     }
  79.     if ($elem eq "dbfile") {        # Database file
  80.         while ($line = <FMT>) {
  81.         last  if $line =~ /^\s*<\/dbfile\s*>/i;
  82.         next  if $line =~ /^\s*$/;
  83.         $line =~ s/\s//g; $DBFILE = $line;
  84.         }
  85.         last FMTSW;
  86.     }
  87.     if ($elem eq "excs") {            # Exclude header fields
  88.         %HFieldsExc = ()  if $override;
  89.         while ($line = <FMT>) {
  90.         last  if $line =~ /^\s*<\/excs\s*>/i;
  91.         $line =~ s/\s//g;  $line =~ tr/A-Z/a-z/;
  92.         $HFieldsExc{$line} = 1  if $line;
  93.         }
  94.         last FMTSW;
  95.     }
  96.     if ($elem eq "fieldstyles") {        # Field text style
  97.         while ($line = <FMT>) {
  98.         last  if $line =~ /^\s*<\/fieldstyles\s*>/i;
  99.         next  if $line =~ /^\s*$/;
  100.         $line =~ s/\s//g;  $line =~ tr/A-Z/a-z/;
  101.         ($label, $tag) = split(/:/,$line);
  102.         $HeadFields{$label} = $tag;
  103.         }
  104.         last FMTSW;
  105.     }
  106.     if ($elem eq "fieldorder") {        # Field order
  107.         @FieldOrder = ();  %FieldODefs = ();
  108.         while ($line = <FMT>) {
  109.         last  if $line =~ /^\s*<\/fieldorder\s*>/i;
  110.         next  if $line =~ /^\s*$/;
  111.         $line =~ s/\s//g;  $line =~ tr/A-Z/a-z/;
  112.         push(@FieldOrder, $line);
  113.         $FieldODefs{$line} = 1;
  114.         }
  115.         push(@FieldOrder,'-extra-')  if (!$FieldODefs{'-extra-'});
  116.         last FMTSW;
  117.     }
  118.     if ($elem eq "footer") {        # Footer file
  119.         while ($line = <FMT>) {
  120.         last  if $line =~ /^\s*<\/footer\s*>/i;
  121.         next  if $line =~ /^\s*$/;
  122.         $line =~ s/\s//g;
  123.         $FOOTER = $line;
  124.         }
  125.         last FMTSW;
  126.     }
  127.     if ($elem eq "header") {        # Header file
  128.         while ($line = <FMT>) {
  129.         last  if $line =~ /^\s*<\/header\s*>/i;
  130.         next  if $line =~ /^\s*$/;
  131.         $line =~ s/\s//g;
  132.         $HEADER = $line;
  133.         }
  134.         last FMTSW;
  135.     }
  136.     if ($elem eq "icons") {            # Icons
  137.         %Icons = ()  if $override;
  138.         while ($line = <FMT>) {
  139.         last  if $line =~ /^\s*<\/icons\s*>/i;
  140.         next  if $line =~ /^\s*$/;
  141.         $line =~ s/\s//g;
  142.         ($type, $url) = split(/:/,$line,2);
  143.         $type =~ tr/A-Z/a-z/;
  144.         $Icons{$type} = $url;
  145.         }
  146.         last FMTSW;
  147.     }
  148.     if ($elem eq "idxfname") {        # Index filename
  149.         while ($line = <FMT>) {
  150.         last  if $line =~ /^\s*<\/idxfname\s*>/i;
  151.         next  if $line =~ /^\s*$/;
  152.         $line =~ s/\s//g;
  153.         $IDXNAME = $line;
  154.         }
  155.         last FMTSW;
  156.     }
  157.     if ($elem eq "idxpgbegin") {        # Opening markup of index
  158.         $IDXPGBEG = '';
  159.         while ($line = <FMT>) {
  160.         last  if $line =~ /^\s*<\/idxpgbegin\s*>/i;
  161.         $IDXPGBEG .= $line;
  162.         }
  163.         last FMTSW;
  164.     }
  165.     if ($elem eq "idxpgend") {        # Closing markup of index
  166.         $IDXPGEND = '';
  167.         while ($line = <FMT>) {
  168.         last  if $line =~ /^\s*<\/idxpgend\s*>/i;
  169.         $IDXPGEND .= $line;
  170.         }
  171.         last FMTSW;
  172.     }
  173.     if ($elem eq "idxsize") {        # Size of index
  174.         while ($line = <FMT>) {
  175.         last  if $line =~ /^\s*<\/idxsize\s*>/i;
  176.         next  if $line =~ /^\s*$/;
  177.         $line =~ s/\s//g;
  178.         $IDXSIZE = $line  if ($line =~ /^\d+$/);
  179.         }
  180.         last FMTSW;
  181.     }
  182.     if ($elem eq "labelstyles") {        # Field label style
  183.         while ($line = <FMT>) {
  184.         last  if $line =~ /^\s*<\/labelstyles\s*>/i;
  185.         next  if $line =~ /^\s*$/;
  186.         $line =~ s/\s//g;  $line =~ tr/A-Z/a-z/;
  187.         ($label, $tag) = split(/:/,$line);
  188.         $HeadHeads{$label} = $tag;
  189.         }
  190.         last FMTSW;
  191.     }
  192.     if ($elem eq "listbegin") {        # List begin
  193.         $LIBEG = '';
  194.         while ($line = <FMT>) {
  195.         last  if $line =~ /^\s*<\/listbegin\s*>/i;
  196.         $LIBEG .= $line;
  197.         }
  198.         last FMTSW;
  199.     }
  200.     if ($elem eq "listend") {        # List end
  201.         $LIEND = '';
  202.         while ($line = <FMT>) {
  203.         last  if $line =~ /^\s*<\/listend\s*>/i;
  204.         $LIEND .= $line;
  205.         }
  206.         last FMTSW;
  207.     }
  208.     if ($elem eq "litemplate") {        # List item template
  209.         $LITMPL = '';
  210.         while ($line = <FMT>) {
  211.         last  if $line =~ /^\s*<\/litemplate\s*>/i;
  212.         $LITMPL .= $line;
  213.         }
  214.         last FMTSW;
  215.     }
  216.     if ($elem eq "mailtourl") {        # mailto URL
  217.         while ($line = <FMT>) {
  218.         last  if $line =~ /^\s*<\/mailtourl\s*>/i;
  219.         next  if $line =~ /^\s*$/;
  220.         $line =~ s/\s//g;
  221.         $MAILTOURL = $line;
  222.         }
  223.         last FMTSW;
  224.     }
  225.     if ($elem eq "maxsize") {        # Size of archive
  226.         while ($line = <FMT>) {
  227.         last  if $line =~ /^\s*<\/maxsize\s*>/i;
  228.         next  if $line =~ /^\s*$/;
  229.         $line =~ s/\s//g;
  230.         $MAXSIZE = $line  if ($line =~ /^\d+$/);
  231.         }
  232.         last FMTSW;
  233.     }
  234.     if ($elem eq "mimefilters") {        # Mime filters
  235.         @Requires = (), %MIMEFilters = ()  if $override;
  236.         while ($line = <FMT>) {
  237.         last  if $line =~ /^\s*<\/mimefilters\s*>/i;
  238.         next  if $line =~ /^\s*$/;
  239.         $line =~ s/\s//g;
  240.         ($type,$routine,$plfile) = split(/:/,$line,3);
  241.         $type =~ tr/A-Z/a-z/;
  242.         $MIMEFilters{$type} = $routine;
  243.         push(@Requires, $plfile);
  244.         }
  245.         last FMTSW;
  246.     }
  247.     if ($elem eq "mimeargs") {        # Mime arguments
  248.         %MIMEFiltersArgs = ()  if $override;
  249.         while ($line = <FMT>) {
  250.         last  if $line =~ /^\s*<\/mimeargs\s*>/i;
  251.         next  if $line =~ /^\s*$/;
  252.         ($type,$arg) = split(/:/,$line,2);
  253.         $type =~ tr/A-Z/a-z/  if $type =~ m%/%;
  254.         $MIMEFiltersArgs{$type} = $arg;
  255.         }
  256.         last FMTSW;
  257.     }
  258.     if ($elem eq "msgfoot") {        # Message footer text
  259.         $MSGFOOT = '';
  260.         while ($line = <FMT>) {
  261.         last  if $line =~ /^\s*<\/msgfoot\s*>/i;
  262.         $MSGFOOT .= $line;
  263.         }
  264.         last FMTSW;
  265.     }
  266.     if ($elem eq "msghead") {        # Message header text
  267.         $MSGHEAD = '';
  268.         while ($line = <FMT>) {
  269.         last  if $line =~ /^\s*<\/msghead\s*>/i;
  270.         $MSGHEAD .= $line;
  271.         }
  272.         last FMTSW;
  273.     }
  274.     if ($elem eq "msgpgbegin") {        # Opening markup of message
  275.         $MSGPGBEG = '';
  276.         while ($line = <FMT>) {
  277.         last  if $line =~ /^\s*<\/msgpgbegin\s*>/i;
  278.         $MSGPGBEG .= $line;
  279.         }
  280.         last FMTSW;
  281.     }
  282.     if ($elem eq "msgpgend") {        # Closing markup of message
  283.         $MSGPGEND = '';
  284.         while ($line = <FMT>) {
  285.         last  if $line =~ /^\s*<\/msgpgend\s*>/i;
  286.         $MSGPGEND .= $line;
  287.         }
  288.         last FMTSW;
  289.     }
  290.     if ($elem eq "msgsep") {        # Message separator
  291.         while ($line = <FMT>) {
  292.         last  if $line =~ /^\s*<\/msgsep\s*>/i;
  293.         next  if $line =~ /^\s*$/;
  294.         chop $line;
  295.         $FROM = $line;
  296.         }
  297.         last FMTSW;
  298.     }
  299.     if ($elem eq "nextbutton") {        # Next button link in message
  300.         $NEXTBUTTON = '';
  301.         while ($line = <FMT>) {
  302.         last  if $line =~ /^\s*<\/nextbutton\s*>/i;
  303.         $NEXTBUTTON .= $line;
  304.         }
  305.         chop $NEXTBUTTON;
  306.         last FMTSW;
  307.     }
  308.     if ($elem eq "nextbuttonia") {
  309.         $NEXTBUTTONIA = '';
  310.         while ($line = <FMT>) {
  311.         last  if $line =~ /^\s*<\/nextbuttonia\s*>/i;
  312.         $NEXTBUTTONIA .= $line;
  313.         }
  314.         chop $NEXTBUTTONIA;
  315.         last FMTSW;
  316.     }
  317.     if ($elem eq "nextlink") {        # Next link in message
  318.         $NEXTLINK = '';
  319.         while ($line = <FMT>) {
  320.         last  if $line =~ /^\s*<\/nextlink\s*>/i;
  321.         $NEXTLINK .= $line;
  322.         }
  323.         last FMTSW;
  324.     }
  325.     if ($elem eq "nextlinkia") {
  326.         $NEXTLINKIA = '';
  327.         while ($line = <FMT>) {
  328.         last  if $line =~ /^\s*<\/nextlinkia\s*>/i;
  329.         $NEXTLINKIA .= $line;
  330.         }
  331.         last FMTSW;
  332.     }
  333.     if ($elem eq "nodoc") {
  334.         $NODOC = 1; last FMTSW;
  335.     }
  336.     if ($elem eq "nonews") {
  337.         $NONEWS = 1; last FMTSW;
  338.     }
  339.     if ($elem eq "nomailto") {
  340.         $NOMAILTO = 1; last FMTSW;
  341.     }
  342.     if ($elem eq "noreverse") {
  343.         $REVSORT = 0; last FMTSW;
  344.     }
  345.     if ($elem eq "nosort") {
  346.         $NOSORT = 1;  $SUBSORT = 0; last FMTSW;
  347.     }
  348.     if ($elem eq "nothread") {
  349.         $THREAD = 0; last FMTSW;
  350.     }
  351.     if ($elem eq "notreverse") {
  352.         $TREVERSE = 0; last FMTSW;
  353.     }
  354.     if ($elem eq "notsubsort") {
  355.         $TSUBSORT = 0; last FMTSW;
  356.     }
  357.     if ($elem eq "nourl") {
  358.         $NOURL = 1; last FMTSW;
  359.     }
  360.     if ($elem eq "otherindexes") {        # Other indexes
  361.         @OtherIdxs = ();
  362.         while ($line = <FMT>) {
  363.         last  if $line =~ /^\s*<\/otherindexes\s*>/i;
  364.         next  if $line =~ /^\s*$/;
  365.         $line =~ s/\s//g;
  366.         push(@OtherIdxs, $line);
  367.         }
  368.         last FMTSW;
  369.     }
  370.     if ($elem eq "perlinc") {        # Message separator
  371.         @PerlINC = ()  if $override;
  372.         while ($line = <FMT>) {
  373.         last  if $line =~ /^\s*<\/perlinc\s*>/i;
  374.         next  if $line =~ /^\s*$/;
  375.         $line =~ s/\s//g;
  376.         unshift(@PerlINC, $line);
  377.         }
  378.         last FMTSW;
  379.     }
  380.     if ($elem eq "prevbutton") {        # Prev button link in message
  381.         $PREVBUTTON = '';
  382.         while ($line = <FMT>) {
  383.         last  if $line =~ /^\s*<\/prevbutton\s*>/i;
  384.         $PREVBUTTON .= $line;
  385.         }
  386.         chop $PREVBUTTON;
  387.         last FMTSW;
  388.     }
  389.     if ($elem eq "prevbuttonia") {
  390.         $PREVBUTTONIA = '';
  391.         while ($line = <FMT>) {
  392.         last  if $line =~ /^\s*<\/prevbuttonia\s*>/i;
  393.         $PREVBUTTONIA .= $line;
  394.         }
  395.         chop $PREVBUTTONIA;
  396.         last FMTSW;
  397.     }
  398.     if ($elem eq "prevlink") {        # Prev link in message
  399.         $PREVLINK = '';
  400.         while ($line = <FMT>) {
  401.         last  if $line =~ /^\s*<\/prevlink\s*>/i;
  402.         $PREVLINK .= $line;
  403.         }
  404.         last FMTSW;
  405.     }
  406.     if ($elem eq "prevlinkia") {
  407.         $PREVLINKIA = '';
  408.         while ($line = <FMT>) {
  409.         last  if $line =~ /^\s*<\/prevlinkia\s*>/i;
  410.         $PREVLINKIA .= $line;
  411.         }
  412.         last FMTSW;
  413.     }
  414.     if ($elem eq "reverse") {
  415.         $REVSORT = 1; last FMTSW;
  416.     }
  417.     if ($elem eq "sort") {
  418.         $NOSORT = 0;  $SUBSORT = 0; last FMTSW;
  419.     }
  420.     if ($elem eq "subsort") {
  421.         $NOSORT = 0;  $SUBSORT = 1; last FMTSW;
  422.     }
  423.     if ($elem eq "thead") {            # Thread idx head
  424.         $THEAD = '';
  425.         while ($line = <FMT>) {
  426.         last  if $line =~ /^\s*<\/thead\s*>/i;
  427.         $THEAD .= $line;
  428.         }
  429.         last FMTSW;
  430.     }
  431.     if ($elem eq "tfoot") {            # Thread idx foot
  432.         $TFOOT = '';
  433.         while ($line = <FMT>) {
  434.         last  if $line =~ /^\s*<\/tfoot\s*>/i;
  435.         $TFOOT .= $line;
  436.         }
  437.         last FMTSW;
  438.     }
  439.     if ($elem eq "tidxfname") {        # Threaded idx filename
  440.         while ($line = <FMT>) {
  441.         last  if $line =~ /^\s*<\/tidxfname\s*>/i;
  442.         next  if $line =~ /^\s*$/;
  443.         $line =~ s/\s//g;
  444.         $TIDXNAME = $line;
  445.         }
  446.         last FMTSW;
  447.     }
  448.     if ($elem eq "tidxpgbegin") {        # Opening markup of thread idx
  449.         $TIDXPGBEG = '';
  450.         while ($line = <FMT>) {
  451.         last  if $line =~ /^\s*<\/tidxpgbegin\s*>/i;
  452.         $TIDXPGBEG .= $line;
  453.         }
  454.         last FMTSW;
  455.     }
  456.     if ($elem eq "tidxpgend") {        # Closing markup of thread idx
  457.         $TIDXPGEND = '';
  458.         while ($line = <FMT>) {
  459.         last  if $line =~ /^\s*<\/tidxpgend\s*>/i;
  460.         $TIDXPGEND .= $line;
  461.         }
  462.         last FMTSW;
  463.     }
  464.     if ($elem eq "timezones") {        # Time zones
  465.         %Zone = ()  if $override;
  466.         while ($line = <FMT>) {
  467.         last  if $line =~ /^\s*<\/timezones\s*>/i;
  468.         $line =~ s/\s//g;  $line =~ tr/a-z/A-Z/;
  469.         ($acro,$hr) = split(/:/,$line);
  470.         $Zone{$acro} = $hr;
  471.         }
  472.         last FMTSW;
  473.     }
  474.     if ($elem eq "title") {            # Title of index page
  475.         $TITLE = '';
  476.         while ($line = <FMT>) {
  477.         last  if $line =~ /^\s*<\/title\s*>/i;
  478.         $TITLE .= $line;
  479.         }
  480.         last FMTSW;
  481.     }
  482.     if ($elem eq "tlevels") {        # Level of threading
  483.         while ($line = <FMT>) {
  484.         last  if $line =~ /^\s*<\/tlevels\s*>/i;
  485.         next  if $line =~ /^\s*$/;
  486.         $line =~ s/\s//g;
  487.         $TLEVELS = $line  if ($line =~ /^\d+$/);
  488.         }
  489.         last FMTSW;
  490.     }
  491.     if ($elem eq "tlitxt") {        # Thread idx <li> txt
  492.         $TLITXT = '';
  493.         while ($line = <FMT>) {
  494.         last  if $line =~ /^\s*<\/tlitxt\s*>/i;
  495.         $TLITXT .= $line;
  496.         }
  497.         last FMTSW;
  498.     }
  499.     if ($elem eq "toplinks") {        # Top links in message
  500.         $TOPLINKS = '';
  501.         while ($line = <FMT>) {
  502.         last  if $line =~ /^\s*<\/toplinks\s*>/i;
  503.         $TOPLINKS .= $line;
  504.         }
  505.         last FMTSW;
  506.     }
  507.     if ($elem eq "tsubsort") {
  508.         $TSUBSORT = 1; last FMTSW;
  509.     }
  510.     if ($elem eq "ttitle") {        # Title of threaded idx
  511.         $TTITLE = '';
  512.         while ($line = <FMT>) {
  513.         last  if $line =~ /^\s*<\/ttitle\s*>/i;
  514.         $TTITLE .= $line;
  515.         }
  516.         last FMTSW;
  517.     }
  518.     if ($elem eq "thread") {
  519.         $THREAD = 1; last FMTSW;
  520.     }
  521.     if ($elem eq "treverse") {
  522.         $TREVERSE = 1; last FMTSW;
  523.     }
  524.     if ($elem eq "umask") {        # Umask of process
  525.         while ($line = <FMT>) {
  526.         last  if $line =~ /^\s*<\/umask\s*>/i;
  527.         next  if $line =~ /^\s*$/;
  528.         chop $line;
  529.         $UMASK = $line;
  530.         }
  531.         last FMTSW;
  532.     }
  533.  
  534.     } ## End FMTSW
  535.     }
  536.     close(FMT);
  537.     1;
  538. }
  539. ##---------------------------------------------------------------------------
  540. ##    Get an e-mail address from (HTML) $str.
  541. ##
  542. sub extract_email_address {
  543.     local($str) = shift;
  544.     local($ret);
  545.  
  546.     if ($str =~ /\<(\S+)\>/) {
  547.     $ret = $1;
  548.     } elsif ($str =~ s/\([^\)]+\)//) {
  549.     $str =~ /\s*(\S+)\s*/;  $ret = $1;
  550.     } else {
  551.     $str =~ /\s*(\S+)\s*/;  $ret = $1;
  552.     }
  553.     $ret;
  554. }
  555. ##---------------------------------------------------------------------------
  556. ##    Get an e-mail name from (HTML) $str.
  557. ##
  558. sub extract_email_name {
  559.     local($str) = shift;
  560.     local($ret);
  561.  
  562.     if ($str =~ s/\<(\S+)\>//) {        # Check for: name <addr>
  563.     $ret = $1;
  564.     if ($str !~ /^\s*$/) {        # strip extra whitespace
  565.         ($ret = $str) =~ s/\s+/ /g;
  566.     } else {            # no name
  567.         $ret =~ s/@.*//;
  568.     }
  569.     $ret =~ s/^\s*"//;
  570.     $ret =~ s/"\s*$//;
  571.     } elsif ($str =~ /"([^"]+)"/) {        # Name in ""'s
  572.     $ret = $1;
  573.     } elsif ($str =~ /\(([^\)]+)\)/) {        # Name in ()'s
  574.     $ret = $1;
  575.     } else {                    # Just address
  576.     ($ret = $str) =~ s/@.*//;
  577.     }
  578.     $ret;
  579. }
  580. ##---------------------------------------------------------------------------
  581. ##    Routine to sort messages
  582. ##
  583. sub sort_messages {
  584.     local(@a);
  585.     if ($NOSORT) {                # Message processed order
  586.     if ($REVSORT) { @a = sort decrease_msgnum keys %Subject; }
  587.     else { @a = sort increase_msgnum keys %Subject; }
  588.  
  589.     } elsif ($SUBSORT) {            # Subject order
  590.     if ($REVSORT) { @a = sort decrease_subject keys %Subject; }
  591.     else { @a = sort increase_subject keys %Subject; }
  592.  
  593.     } else {                    # Date order
  594.     if ($REVSORT) { @a = sort decrease_index keys %Subject; }
  595.     else { @a = sort increase_index keys %Subject; }
  596.     }
  597.     @a;
  598. }
  599. ##---------------------------------------------------------------------------
  600. ##    Message-sort routines for sort_messages
  601. ##
  602. sub increase_msgnum {
  603.     local(@A) = split(/$'X/o, $a);
  604.     local(@B) = split(/$'X/o, $b);
  605.     local($sret);
  606.     $sret = $A[1] <=> $B[1];
  607.     ($sret == 0 ? $A[0] <=> $B[0] : $sret);
  608. }
  609. sub decrease_msgnum {
  610.     local(@A) = split(/$'X/o, $a);
  611.     local(@B) = split(/$'X/o, $b);
  612.     local($sret);
  613.     $sret = $B[1] <=> $A[1];
  614.     ($sret == 0 ? $B[0] <=> $A[0] : $sret);
  615. }
  616. sub increase_index {
  617.     local(@A) = split(/$'X/o, $a);
  618.     local(@B) = split(/$'X/o, $b);
  619.     local($sret);
  620.     $sret = $A[0] <=> $B[0];
  621.     ($sret == 0 ? $A[1] <=> $B[1] : $sret);
  622. }
  623. sub decrease_index {
  624.     local(@A) = split(/$'X/o, $a);
  625.     local(@B) = split(/$'X/o, $b);
  626.     local($sret);
  627.     $sret = $B[0] <=> $A[0];
  628.     ($sret == 0 ? $B[1] <=> $A[1] : $sret);
  629. }
  630. sub increase_subject {
  631.     local($A, $B) = ($Subject{$a}, $Subject{$b});
  632.     local($at, $bt) = ((split(/$'X/o, $a))[0], (split(/$'X/o, $b))[0]);
  633.     $A =~ tr/A-Z/a-z/;  $B =~ tr/A-Z/a-z/; 
  634.     1 while $A =~ s/^\s*(re|sv|fwd|fw)[:>-]+\s*//i;
  635.     1 while $B =~ s/^\s*(re|sv|fwd|fw)[:>-]+\s*//i;
  636.     $A =~ s/^(the|a|an)\s+//i;  $B =~ s/^(the|a|an)\s+//i;
  637.     local($sret) = ($A cmp $B);
  638.     ($sret == 0 ? $at <=> $bt : $sret);
  639. }
  640. sub decrease_subject {
  641.     local($A, $B) = ($Subject{$a}, $Subject{$b});
  642.     local($at, $bt) = ((split(/$'X/o, $a))[0], (split(/$'X/o, $b))[0]);
  643.     $A =~ tr/A-Z/a-z/;  $B =~ tr/A-Z/a-z/; 
  644.     1 while $A =~ s/^\s*(re|sv|fwd|fw)[:>-]+\s*//i;
  645.     1 while $B =~ s/^\s*(re|sv|fwd|fw)[:>-]+\s*//i;
  646.     $A =~ s/^(the|a|an)\s+//i;  $B =~ s/^(the|a|an)\s+//i;
  647.     local($sret) = ($B cmp $A);
  648.     ($sret == 0 ? $bt <=> $at : $sret);
  649. }
  650. ##---------------------------------------------------------------------------
  651. ##    Routine to determine last message number in use.
  652. ##
  653. sub get_last_msg_num {
  654.     local(@files) = ();
  655.     local($n);
  656.     opendir(DIR, $'OUTDIR) || &error("ERROR: Unable to open $'OUTDIR");
  657.     @files = sort by_msgnum grep(/^msg\d+\.html?$/i, readdir(DIR));
  658.     grep(s/msg0+(\d)/msg$1/i, @files);
  659.     close(DIR);
  660.     if (@files) {
  661.     ($n) = $files[$#files] =~ /(\d+)/;
  662.     } else {
  663.     $n = -1;
  664.     }
  665.     $n;
  666. }
  667. sub by_msgnum {
  668.     ($A) = $a =~ /(\d+)/;
  669.     ($B) = $b =~ /(\d+)/;
  670.     $A <=> $B;
  671. }
  672. ##---------------------------------------------------------------------------
  673. ##    Routine for formating a message number for use in filenames or links.
  674. ##
  675. sub fmt_msgnum {
  676.     local($num) = $_[0];
  677.     sprintf("%05d", $num);
  678. }
  679. ##---------------------------------------------------------------------------
  680. ##    Routine to get filename of a message number.
  681. ##
  682. sub msgnum_filename {
  683.     local($num) = $_[0];
  684.     sprintf("msg%05d.html", $num);
  685. }
  686. ##---------------------------------------------------------------------------##
  687. ##    MHonArc independent routines
  688. ##---------------------------------------------------------------------------##
  689. ##---------------------------------------------------------------------------
  690. ##    parse_date takes a string date specified like the output of
  691. ##    date(1) into its components.
  692. ##
  693. sub parse_date {
  694.     local($date) = $_[0];
  695.     local($wday, $mday, $mon, $yr, $time, $hr, $min, $sec, $zone);
  696.     local(@array);
  697.  
  698.     $date =~ s/^\s*//;
  699.     @array = split(' ', $date);
  700.     if ($array[0] =~ /\d/) {        # DD Mon YY HH:MM:SS Zone
  701.     ($mday, $mon, $yr, $time, $zone) = @array;
  702.     } elsif ($array[1] =~ /\d/) {   # Wdy DD Mon YY HH:MM:SS Zone
  703.     ($wday, $mday, $mon, $yr, $time, $zone) = @array;
  704.     } else {                        # Wdy Mon DD HH:MM:SS Zone YYYY
  705.     ($wday, $mon, $mday, $time, $zone, $yr) = @array;
  706.     if ($zone =~ /\d/) {        # No zone
  707.         $yr = $zone;
  708.         $zone = '';
  709.     }
  710.     }
  711.     ($hr, $min, $sec) = split(/:/, $time);
  712.     $sec = 0  unless $sec;          # Sometime seconds not defined
  713.  
  714.     ($WDay2Num{$wday}, $mday, $Month2Num{$mon}, $yr, $hr, $min, $sec, $zone);
  715. }
  716. ##---------------------------------------------------------------------------
  717. ##
  718. sub time2mmddyy {
  719.     local($time, $fmt) = ($_[0], $_[1]);
  720.     local($day,$mon,$year);
  721.     if ($time) {
  722.     ($day,$mon,$year) = (localtime($time))[3,4,5];
  723.     if ($fmt =~ /ddmmyy/i) {
  724.         $tmp = sprintf("%02d/%02d/%02d", $day, $mon+1, $year);
  725.     } elsif ($fmt =~ /yymmdd/i) {
  726.         $tmp = sprintf("%02d/%02d/%02d", $year, $mon+1, $day);
  727.     } else {
  728.         $tmp = sprintf("%02d/%02d/%02d", $mon+1, $day, $year);
  729.     }
  730.     } else {
  731.     $tmp = "--/--/--";
  732.     }
  733. }
  734. ##---------------------------------------------------------------------------
  735. ##    Remove duplicates in an array.
  736. ##
  737. sub remove_dups {
  738.     local(*array) = shift;
  739.     local(%dup);
  740.     @array = grep($dup{$_}++ < 1, @array);
  741.     %dup = ();
  742. }
  743. ##---------------------------------------------------------------------------
  744. ##    numerically() is used to tell 'sort' to sort by numbers.
  745. ##
  746. sub numerically {
  747.     $a <=> $b;
  748. }
  749. ##---------------------------------------------------------------------------
  750. ##    "Entify" special characters
  751. ##
  752. sub htmlize {            # Older name, variable passed by reference
  753.     local(*txt) = $_[0];
  754.     $txt =~ s/&/\&/g;
  755.     $txt =~ s/>/>/g;
  756.     $txt =~ s/</</g;
  757.     $txt;
  758. }
  759. sub entify {            # Newer name, variable passed by copy
  760.     local($txt) = $_[0];
  761.     $txt =~ s/&/\&/g;
  762.     $txt =~ s/>/>/g;
  763.     $txt =~ s/</</g;
  764.     $txt;
  765. }
  766. ##---------------------------------------------------------------------------
  767. ##    Copy a file.
  768. ##
  769. sub cp {
  770.     local($src, $dst) = @_;
  771.     open(SRC, $src) || &error("ERROR: Unable to open $src");
  772.     open(DST, "> $dst") || &error("ERROR: Unable to create $dst");
  773.     print DST <SRC>;
  774.     close(SRC);
  775.     close(DST);
  776. }
  777. ##---------------------------------------------------------------------------
  778. ##    Get date in date(1)-like format.  $local flag is if local time
  779. ##    should be used.
  780. ##
  781. sub getdate {
  782.     local($local) = $_[0];
  783.     local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst);
  784.     local($curtime) = (time());
  785.  
  786.     ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
  787.     ($local ? localtime($curtime) : gmtime($curtime));
  788.     sprintf("%s %s %02d %02d:%02d:%02d " . ($local ? "%s" : "GMT %s"),
  789.         (Sun,Mon,Tue,Wed,Thu,Fri,Sat)[$wday],
  790.         (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec)[$mon],
  791.         $mday, $hour, $min, $sec, $year);
  792. }
  793. ##---------------------------------------------------------------------------
  794. ##    Translate html string back to regular string
  795. ##
  796. sub dehtmlize {
  797.     local($str) = shift;
  798.     $str =~ s/\</</g;
  799.     $str =~ s/\>/>/g;
  800.     $str =~ s/\&/\&/g;
  801.     $str;
  802. }
  803. ##---------------------------------------------------------------------------
  804. ##    Escape special characters in string for URL use.
  805. ##
  806. sub urlize {
  807.     local($url) = shift;
  808.     $url =~ s/([{}\[\]\\^~<>\?%=\+ \t])/sprintf("%%%X",unpack("C",$1))/ge;
  809.     $url;
  810. }
  811. ##---------------------------------------------------------------------------##
  812.  
  813. 1;
  814.